home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / SIOD / siod.scm < prev    next >
Encoding:
Text File  |  1993-10-01  |  6.7 KB  |  190 lines
  1. ; Scheme In One Define.
  2. ; 
  3. ; The garbage collector, the name and other parts of this program are
  4. ;
  5. ; *                     COPYRIGHT (c) 1989 BY                              *
  6. ; *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7. ;
  8. ; Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. ; rational numbers, debug utils, and other major enhancments by
  10. ;
  11. ; *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12. ;
  13. ; Permission  to use, copy, modify, distribute and sell this software and its
  14. ; documentation  for  any purpose and without fee is hereby granted, provided
  15. ; that  the  above  copyright  notice appear in all copies and that both that
  16. ; copyright   notice   and   this  permission  notice  appear  in  supporting
  17. ; documentation,  and that the name of Paradigm Associates Inc not be used in
  18. ; advertising or publicity pertaining to distribution of the software without
  19. ; specific, written prior permission.
  20. ;
  21. ; Runtime library for version 2.6
  22.  
  23. (define my-path "SIOD:")
  24.  
  25. (autoload-from-file (string-append my-path "cxr.scm")
  26.                     '(caar cadr cdar cddr 
  27.                       caaar caadr cadar caddr  
  28.                       cdaar cdadr cddar cdddr  
  29.                       caaaar caaadr caadar caaddr 
  30.                       cadaar cadadr caddar cadddr 
  31.                       cdaaar cdaadr cdadar cdaddr 
  32.                       cddaar cddadr cdddar cddddr
  33.                       1st 2nd 3rd 4th)
  34.                      user-global-environment)
  35.  
  36. (autoload-from-file (string-append my-path "delay.scm") 
  37.                     '(freeze thaw delay force delayed-object?)
  38.                     user-global-environment)
  39.  
  40. (autoload-from-file (string-append my-path "streams.scm")
  41.                     '(cons-stream head tail the-empty-stream 
  42.                       empty-stream? stream? stream->list list->stream
  43.                       stream-map stream-append stream-filter stream-ref
  44.                       stream-nth stream-for-each)
  45.                     user-global-environment)     
  46.  
  47. (autoload-from-file (string-append my-path "port.scm") 
  48.                     '(file-length open-binary-input-file
  49.                       open-binary-output-file open-input-file
  50.                       open-output-file open-extend-file
  51.                       current-input-port current-output-port
  52.                       newline page call-with-input-file
  53.                       call-with-output-file with-input-from-file
  54.                       with-output-to-file)
  55.                     user-global-environment)
  56.  
  57. (autoload-from-file (string-append my-path "string.scm")
  58.                     '(string<? string>? string=? string<=?
  59.                       string>=? string-CI<? string-CI=? string-null?)
  60.                     user-global-environment)
  61.  
  62.  
  63. (autoload-from-file (string-append my-path "substring.scm") 
  64.                     '(substring-CI<? substring-CI=? substring<?
  65.                       substring=? substring-fill! 
  66.                       substring-move-left! substring-move-right!
  67.                       substring-find-next-char-in-set 
  68.                       substring-find-previous-char-in-set)
  69.                     user-global-environment)
  70.  
  71. (autoload-from-file (string-append my-path "exp-imp.scm")
  72.                     '(implode explode)
  73.                     user-global-environment)
  74.  
  75.  
  76. (autoload-from-file (string-append my-path "char.scm") 
  77.                     '(char<? char>? char=? char<=? char>=?
  78.                       char-ci<? char-ci>? char-ci=? char-ci<=?
  79.                       char-ci>=? char-upper-case?
  80.                       char-lower-case? char-digit?)
  81.                     user-global-environment)
  82.  
  83. (autoload-from-file (string-append my-path "sort.scm") 
  84.                     '(sort!)
  85.                     user-global-environment)
  86.  
  87. (autoload-from-file (string-append my-path "debug.scm") 
  88.                     '(break unbreak *tracer* trace untrace assert)
  89.                     user-global-environment)
  90.  
  91. (autoload-from-file (string-append my-path "vector.scm") 
  92.                     '(vector-copy vector-append vector-reverse
  93.                       vector-reverse! vector-map vector-for-each)
  94.                     user-global-environment)
  95.  
  96. (define #\backspace (integer->char 8))
  97.  
  98. (define #\escape (integer->char 27))
  99.  
  100. (define #\newline (integer->char 10))
  101.  
  102. (define #\page (integer->char 12))
  103.  
  104. (define #\return (integer->char 13))
  105.  
  106. (define #\rubout (integer->char 63))
  107.  
  108. (define #\space (integer->char 32))
  109.  
  110. (define #\tab (integer->char 9))
  111.  
  112. (macro make-environment (lambda (x)
  113.                                 `(let () 
  114.                                       ,@(cdr x) 
  115.                                       (the-environment))))
  116.  
  117. (macro alias 
  118.        (lambda (x)
  119.                `(macro ,(cadr x)
  120.                        (lambda (e)
  121.                                (if (pair? e) 
  122.                                    (cons ,(caddr x) (cdr e))
  123.                                    ,(caddr x))))))
  124.  
  125. (macro rec (lambda (x)
  126.                    `(letrec ((,(cadr x) ,(caddr x)))
  127.                             ,(cadr x))))
  128.  
  129. (define (boolean? x) (or (eq? x #t) (eq? x #f)))
  130.  
  131. (define time-of-day runtime)
  132.  
  133. (define nth list-ref)
  134.  
  135. (define (compose x y)
  136.         (eval `(lambda a (,x (apply ,y a)))))
  137.  
  138. (define (edit)
  139.         (begin (dos-call "c:ed siod.tmp")
  140.                (load "siod.tmp" (environment-parent (the-environment)))))
  141.  
  142. (define (ced)
  143.         (dos-call "ced"))
  144.  
  145. (define (call-with-current-continuation fcn)
  146.   (let ((tag (cons nil nil)))
  147.     (*catch tag
  148.        (fcn (lambda (value)
  149.          (*throw tag value))))))
  150.  
  151. (define call/cc call-with-current-continuation)
  152.  
  153. (define (call-on-reset p)
  154.         (if (proc? p)
  155.             (eval `(set! err-stack (cons ,p err-stack))
  156.                   *on-reset-env*)
  157.             (error "arg to call-on-reset must be a procedure"))
  158.         #t)
  159.  
  160. (define *on-reset-env*
  161.         (make-environment (define err-stack)
  162.                           (define p)
  163.                           (define (reset-handler)
  164.                                   (while err-stack
  165.                                          (set! p (car err-stack))
  166.                                          (set! err-stack (cdr err-stack))
  167.                                          (p)))))
  168.  
  169. (set! *on-reset* (access reset-handler *on-reset-env*))
  170.  
  171. (define (uncall-on-reset p)
  172.         (if (proc? p)
  173.         (eval `(set! err-stack (delq! ,p err-stack))
  174.               *on-reset-env*)
  175.             (error "arg to call-on-reset must be a procedure"))
  176.         #t)
  177.  
  178. (macro cycle (lambda (e)
  179.                      `(while #t ,@(cdr e))))
  180.  
  181. (macro repeat 
  182.        (lambda (e)
  183.                `(begin ,(cadr e) (while ,(caddr e) ,(cadr e)))))
  184.  
  185. (macro for
  186.        (lambda (e)
  187.                `(do ((,(cadr e) ,(caddr e) ,(cadddr e)))
  188.                     (,(car (cddddr e)))
  189.                     ,@(cdr (cddddr e)))))
  190.